home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / c-call.lisp < prev    next >
Encoding:
Text File  |  1992-05-19  |  7.3 KB  |  212 lines

  1. ;;; -*- Package: MIPS -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: c-call.lisp,v 1.11 92/03/27 23:25:38 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: c-call.lisp,v 1.11 92/03/27 23:25:38 wlott Exp $
  15. ;;;
  16. ;;; This file contains the VOPs and other necessary machine specific support
  17. ;;; routines for call-out to C.
  18. ;;;
  19. ;;; Written by William Lott.
  20. ;;;
  21. (in-package "MIPS")
  22. (use-package "ALIEN")
  23. (use-package "ALIEN-INTERNALS")
  24.  
  25. (defun my-make-wired-tn (prim-type-name sc-name offset)
  26.   (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
  27.          (sc-number-or-lose sc-name *backend*)
  28.          offset))
  29.  
  30. (defstruct arg-state
  31.   (stack-frame-size 0)
  32.   (did-int-arg nil)
  33.   (float-args 0))
  34.  
  35. (def-alien-type-method (integer :arg-tn) (type state)
  36.   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  37.     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  38.     (setf (arg-state-did-int-arg state) t)
  39.     (multiple-value-bind
  40.     (ptype reg-sc stack-sc)
  41.     (if (alien-integer-type-signed type)
  42.         (values 'signed-byte-32 'signed-reg 'signed-stack)
  43.         (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
  44.       (if (< stack-frame-size 4)
  45.       (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
  46.       (my-make-wired-tn ptype stack-sc stack-frame-size)))))
  47.  
  48. (def-alien-type-method (system-area-pointer :arg-tn) (type state)
  49.   (declare (ignore type))
  50.   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  51.     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  52.     (setf (arg-state-did-int-arg state) t)
  53.     (if (< stack-frame-size 4)
  54.     (my-make-wired-tn 'system-area-pointer
  55.               'sap-reg
  56.               (+ stack-frame-size 4))
  57.     (my-make-wired-tn 'system-area-pointer
  58.               'sap-stack
  59.               stack-frame-size))))
  60.  
  61. (def-alien-type-method (double-float :arg-tn) (type state)
  62.   (declare (ignore type))
  63.   (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
  64.     (float-args (arg-state-float-args state)))
  65.     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
  66.     (setf (arg-state-float-args state) (1+ float-args))
  67.     (cond ((>= stack-frame-size 4)
  68.        (my-make-wired-tn 'double-float
  69.                  'double-stack
  70.                  stack-frame-size))
  71.       ((and (not (arg-state-did-int-arg state))
  72.         (< float-args 2))
  73.        (my-make-wired-tn 'double-float
  74.                  'double-reg
  75.                  (+ (* float-args 2) 12)))
  76.       (t
  77.        (error "Can't put floats in int regs yet.")))))
  78.  
  79. (def-alien-type-method (single-float :arg-tn) (type state)
  80.   (declare (ignore type))
  81.   (let ((stack-frame-size (arg-state-stack-frame-size state))
  82.     (float-args (arg-state-float-args state)))
  83.     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  84.     (setf (arg-state-float-args state) (1+ float-args))
  85.     (cond ((>= stack-frame-size 4)
  86.        (my-make-wired-tn 'single-float
  87.                  'single-stack
  88.                  stack-frame-size))
  89.       ((and (not (arg-state-did-int-arg state))
  90.         (< float-args 2))
  91.        (my-make-wired-tn 'single-float
  92.                  'single-reg
  93.                  (+ (* float-args 2) 12)))
  94.       (t
  95.        (error "Can't put floats in int regs yet.")))))
  96.  
  97.  
  98. (defstruct result-state
  99.   (num-results 0))
  100.  
  101. (def-alien-type-method (integer :result-tn) (type state)
  102.   (let ((num-results (result-state-num-results state)))
  103.     (setf (result-state-num-results state) (1+ num-results))
  104.     (multiple-value-bind
  105.     (ptype reg-sc)
  106.     (if (alien-integer-type-signed type)
  107.         (values 'signed-byte-32 'signed-reg)
  108.         (values 'unsigned-byte-32 'unsigned-reg))
  109.       (my-make-wired-tn ptype reg-sc (+ num-results 2)))))
  110.  
  111. (def-alien-type-method (system-area-pointer :result-tn) (type state)
  112.   (declare (ignore type))
  113.   (let ((num-results (result-state-num-results state)))
  114.     (setf (result-state-num-results state) (1+ num-results))
  115.     (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 2))))
  116.     
  117. (def-alien-type-method (double-float :result-tn) (type state)
  118.   (declare (ignore type))
  119.   (let ((num-results (result-state-num-results state)))
  120.     (setf (result-state-num-results state) (1+ num-results))
  121.     (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
  122.  
  123. (def-alien-type-method (single-float :result-tn) (type state)
  124.   (declare (ignore type))
  125.   (let ((num-results (result-state-num-results state)))
  126.     (setf (result-state-num-results state) (1+ num-results))
  127.     (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
  128.  
  129. (def-alien-type-method (values :result-tn) (type state)
  130.   (mapcar #'(lambda (type)
  131.           (invoke-alien-type-method :result-tn type state))
  132.       (alien-values-type-values type)))
  133.  
  134. (def-vm-support-routine make-call-out-tns (type)
  135.   (let ((arg-state (make-arg-state)))
  136.     (collect ((arg-tns))
  137.       (dolist (arg-type (alien-function-type-arg-types type))
  138.     (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
  139.       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
  140.           (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes)
  141.           (arg-tns)
  142.           (invoke-alien-type-method :result-tn
  143.                     (alien-function-type-result-type type)
  144.                     (make-result-state))))))
  145.  
  146.  
  147. (define-vop (foreign-symbol-address)
  148.   (:translate foreign-symbol-address)
  149.   (:policy :fast-safe)
  150.   (:args)
  151.   (:arg-types (:constant simple-string))
  152.   (:info foreign-symbol)
  153.   (:results (res :scs (sap-reg)))
  154.   (:result-types system-area-pointer)
  155.   (:generator 2
  156.     (inst li res (make-fixup foreign-symbol :foreign))))
  157.  
  158. (define-vop (call-out)
  159.   (:args (function :scs (sap-reg) :target v0)
  160.      (args :more t))
  161.   (:results (results :more t))
  162.   (:ignore args results)
  163.   (:save-p t)
  164.   (:temporary (:sc any-reg :offset 2 :from (:argument 0) :to (:result 0)) v0)
  165.   (:temporary (:sc any-reg :offset lra-offset) lra)
  166.   (:temporary (:sc any-reg :offset code-offset) code)
  167.   (:temporary (:sc non-descriptor-reg :to (:result 0)) ndescr)
  168.   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
  169.   (:vop-var vop)
  170.   (:generator 0
  171.     (let ((lra-label (gen-label))
  172.       (cur-nfp (current-nfp-tn vop)))
  173.       (when cur-nfp
  174.     (store-stack-tn nfp-save cur-nfp))
  175.       (move v0 function)
  176.       (inst compute-lra-from-code lra code lra-label ndescr)
  177.       (inst j (make-fixup "call_into_c" :foreign))
  178.       (inst nop)
  179.  
  180.       (align vm:lowtag-bits)
  181.       (emit-label lra-label)
  182.       (inst lra-header-word)
  183.       (when cur-nfp
  184.     (load-stack-tn cur-nfp nfp-save)))))
  185.  
  186. (define-vop (alloc-number-stack-space)
  187.   (:info amount)
  188.   (:results (result :scs (sap-reg any-reg)))
  189.   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  190.   (:generator 0
  191.     (unless (zerop amount)
  192.       (let ((delta (logandc2 (+ amount 7) 7)))
  193.     (cond ((< delta (ash 1 15))
  194.            (inst subu nsp-tn delta))
  195.           (t
  196.            (inst li temp delta)
  197.            (inst subu nsp-tn temp)))))
  198.     (move result nsp-tn)))
  199.  
  200. (define-vop (dealloc-number-stack-space)
  201.   (:info amount)
  202.   (:policy :fast-safe)
  203.   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  204.   (:generator 0
  205.     (unless (zerop amount)
  206.       (let ((delta (logandc2 (+ amount 7) 7)))
  207.     (cond ((< delta (ash 1 15))
  208.            (inst addu nsp-tn delta))
  209.           (t
  210.            (inst li temp delta)
  211.            (inst addu nsp-tn temp)))))))
  212.